home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 11 / CU Amiga Magazine's Super CD-ROM 11 (1997)(EMAP Images)(GB)(Track 1 of 3)[!][issue 1997-06].iso / cucd / programming / oberonv4 / source / system / fonts.mod (.txt) < prev    next >
Oberon Text  |  1996-07-30  |  10KB  |  311 lines
  1. Syntax10.Scn.Fnt
  2. ParcElems
  3. Alloc
  4. Syntax24b.Scn.Fnt
  5. FoldElems
  6. Syntax10b.Scn.Fnt
  7. (* AMIGA  *)
  8. MODULE Fonts; (* shml/cn 29-Dec-1992, 10-May-94 *)
  9. IMPORT
  10.         SYSTEM, Amiga, DiskFont := AmigaDiskFont, Display, E := AmigaExec, Files, G := AmigaGraphics, C:=Console;
  11. CONST
  12.      FontFileId = 0DBX;
  13.     Name* = ARRAY 32 OF CHAR;
  14.     Font* = POINTER TO FontDesc;
  15.     FontDesc* = RECORD
  16.         name*: Name;
  17.         height*, minX*, maxX*, minY*, maxY*: INTEGER;
  18.         raster*: Display.Font;
  19.         next: Font
  20.     END;
  21.     Default*, First: Font; nofFonts: INTEGER;
  22. PROCEDURE SplitFontName (fn: ARRAY OF CHAR; VAR i, j, size: INTEGER);
  23.     VAR k: INTEGER;
  24. BEGIN i := 0; size := 0;
  25.     WHILE (fn[i] # 0X) & ((fn[i] < "0") OR ("9" < fn[i])) DO INC(i) END;
  26.     j := i; WHILE ("0" <= fn[j]) & (fn[j] <= "9") DO INC(j) END;
  27.     k := i; WHILE k < j DO size := size * 10 + ORD(fn[k]) - 30H; INC(k) END
  28. END SplitFontName;
  29. PROCEDURE Cleanup;
  30.     raster: Amiga.Font;
  31. BEGIN
  32.     IF Amiga.ChipMemPool=0 THEN
  33.         WHILE First # NIL DO
  34.             raster := SYSTEM.VAL(Amiga.Font, First.raster);
  35.             IF (raster.data#0) & (raster.size#0) THEN E.FreeMem(raster.data, raster.size) END;
  36.             First := First.next
  37.         END
  38.     ELSE
  39.         First:=NIL
  40.     END;
  41.     Default := NIL
  42. END Cleanup;
  43. PROCEDURE ClearRaster(VAR raster:Amiga.Font);
  44.     dummy: Amiga.CharInfo;
  45.     i:INTEGER;
  46. BEGIN
  47.     dummy.dx:=0;
  48.     dummy.x:=0;
  49.     dummy.y:=0;
  50.     dummy.w:=0;
  51.     dummy.h:=0;
  52.     dummy.modulo:=0;
  53.     dummy.data:=0;
  54.     dummy.offset:=0;
  55.     FOR i:=0 TO 255 DO
  56.         raster.info[i]:=dummy
  57.     END;
  58.     raster.data:=0;
  59.     raster.size:=0
  60. END ClearRaster;
  61. PROCEDURE SearchFont(name:ARRAY OF CHAR):Font;
  62.     f:Font;
  63. BEGIN
  64.     f:=First;
  65.     LOOP
  66.         IF f=NIL THEN EXIT END;
  67.         IF name=f.name THEN EXIT END;
  68.         f:=f.next
  69.     END;
  70.     RETURN f
  71. END SearchFont;
  72. PROCEDURE AmigaFont(name: ARRAY OF CHAR): Font;
  73.     TextFontPtr=POINTER TO G.TextFont;
  74.     font:Font;
  75.     raster:Amiga.Font;
  76.     tf:TextFontPtr;
  77.     af:G.TextFontPtr;
  78.     PROCEDURE DuplicateBlock(src:LONGINT; size:LONGINT):LONGINT;
  79.         b:SHORTINT;
  80.         dst:LONGINT;
  81.         i:LONGINT;
  82.     BEGIN
  83.         IF Amiga.ChipMemPool#0 THEN
  84.             dst:=E.AllocPooled(Amiga.ChipMemPool, size)
  85.         ELSE
  86.             dst:=E.AllocMem(size,{E.memChip})
  87.         END;
  88.         FOR i:=0 TO size-1 DO SYSTEM.GET(src+i,b); SYSTEM.PUT(dst+i,b) END;
  89.         RETURN dst
  90.     END DuplicateBlock;
  91.     PROCEDURE OpenAmigaFont(name:ARRAY OF CHAR):G.TextFontPtr;
  92.         fontName:ARRAY 32 OF CHAR;
  93.         fontSize:INTEGER;
  94.         fontStyles:SHORTINT;
  95.         i,j:INTEGER;
  96.         textAttr:G.TextAttr;
  97.     BEGIN
  98.         COPY(name,fontName);
  99.         fontStyles:=0;
  100.         SplitFontName(name, i, j, fontSize);
  101.     This will not work, if the fonts are handle in this way.
  102.         LOOP
  103.             CASE fontName[j] OF
  104.             | "B","b": INC(fontStyles,2); INC(j)
  105.             | "C","c": INC(fontStyles,64); INC(j)
  106.             | "E","e": INC(fontStyles,8); INC(j)
  107.             | "I","i": INC(fontStyles,4); INC(j)
  108.             | "U","u": INC(fontStyles,1); INC(j)
  109.             ELSE EXIT
  110.             END;
  111.         END;
  112.         fontName[i]:="."; fontName[i+1]:="f"; fontName[i+2]:="o"; fontName[i+3]:="n"; fontName[i+4]:="t";
  113.         fontName[i+5]:=0X;
  114.         textAttr.name:=SYSTEM.ADR(fontName);
  115.         textAttr.ySize:=fontSize;
  116.         textAttr.style:=fontStyles;
  117.         textAttr.flags:=0;
  118.         RETURN DiskFont.OpenDiskFont(textAttr)
  119.     END OpenAmigaFont;
  120.     PROCEDURE SetFontAndRaster(VAR font:Font; VAR raster:Amiga.Font; tf:TextFontPtr);
  121.     TYPE
  122.         Location=RECORD offset,width:INTEGER END;
  123.         LocationArray=ARRAY 256 OF Location;
  124.         LocationPtr=POINTER TO LocationArray;
  125.         SpaceArray=ARRAY 256 OF INTEGER;
  126.         SpacePtr=POINTER TO SpaceArray;
  127.         KernArray=ARRAY 256 OF INTEGER;
  128.         KernPtr=POINTER TO KernArray;
  129.         ch:INTEGER;
  130.         dx,x,y,w,h:SHORTINT;
  131.         i:INTEGER;
  132.         kern:KernPtr;
  133.         loc:LocationPtr;
  134.         minX,maxX:INTEGER;
  135.         space:SpacePtr;
  136.         li:LONGINT;
  137.     BEGIN
  138.         loc:=SYSTEM.VAL(LocationPtr, tf.charLoc);
  139.         space:=SYSTEM.VAL(SpacePtr, tf.charSpace);
  140.         kern:=SYSTEM.VAL(KernPtr, tf.charKern);
  141.         y:=SHORT(tf.baseline-tf.ySize+1);
  142.         h:=SHORT(tf.ySize);
  143.         font.minY:=y;
  144.         font.maxY:=y+h;
  145.         minX:=MAX(INTEGER); maxX:=MIN(INTEGER);
  146.         raster.size:=tf.modulo*h;
  147.         raster.data:=DuplicateBlock(tf.charData,raster.size);
  148.         FOR ch:=ORD(tf.loChar) TO ORD(tf.hiChar) DO
  149.             i:=ch-ORD(tf.loChar);
  150.             IF space#NIL THEN dx:=SHORT(space[i]) ELSE dx:=SHORT(tf.xSize) END;
  151.             x:=0; IF kern#NIL THEN dx:=dx+SHORT(kern[i]); x:=SHORT(kern[i]) END;
  152.             IF loc#NIL THEN w:=SHORT(loc[i].width) ELSE w:=SHORT(tf.xSize) END;
  153.             IF x<minX THEN minX:=x END;
  154.             IF x+w>maxX THEN maxX:=x+w END;
  155.             raster.info[ch].dx:=dx;
  156.             raster.info[ch].x:=x;
  157.             raster.info[ch].y:=y;
  158.             raster.info[ch].w:=w;
  159.             raster.info[ch].h:=h;
  160.             raster.info[ch].modulo:=tf.modulo;
  161.             raster.info[ch].data:=raster.data;
  162.             IF loc#NIL THEN raster.info[ch].offset:=loc[i].offset ELSE raster.info[ch].offset:=w*i END
  163.         END;
  164.         font.height:=h;
  165.         font.minX:=minX;
  166.         font.maxX:=maxX;
  167.         font.raster:=SYSTEM.VAL(Display.Font,raster)
  168.     END SetFontAndRaster;
  169. BEGIN
  170.     font:=Default;
  171.     af:=OpenAmigaFont(name);
  172.     tf:=SYSTEM.VAL(TextFontPtr, af);
  173.     IF tf#NIL THEN
  174.         NEW(raster);
  175.         ClearRaster(raster);
  176.         NEW(font);
  177.         IF font=NIL THEN HALT(127) END;
  178.         SetFontAndRaster(font,raster,tf);
  179.         raster.amigaFont:=af;
  180.         COPY(name,font.name);
  181.         font.next:=First;
  182.         First:=font;
  183.         G.CloseFont(af)
  184.     END;
  185.     RETURN font
  186. END AmigaFont;
  187. PROCEDURE OberonFont(name: ARRAY OF CHAR): Font;
  188.     RunRec=RECORD
  189.         beg, end: INTEGER
  190.     END;
  191.     RunRecArray=ARRAY 16 OF RunRec;
  192.     ch:CHAR;
  193.     file:Files.File;
  194.     font:Font;
  195.     nOfRuns: INTEGER;
  196.     raster: Amiga.Font;
  197.     rider:Files.Rider;
  198.     run:RunRecArray;
  199.     PROCEDURE ReadShort(VAR r: Files.Rider; VAR x: SHORTINT);
  200.         val: INTEGER;
  201.     BEGIN
  202.         Files.ReadInt(r, val); x := SHORT(val)
  203.     END ReadShort;
  204.     PROCEDURE ReadFontHeader(VAR r: Files.Rider; VAR f:Font; VAR nOfRuns:INTEGER; VAR run:RunRecArray);
  205.         k:INTEGER;
  206.     BEGIN
  207.         Files.ReadInt(r,f.height);
  208.         Files.ReadInt(r,f.minX);
  209.         Files.ReadInt(r,f.maxX);
  210.         Files.ReadInt(r,f.minY);
  211.         Files.ReadInt(r,f.maxY);
  212.         Files.ReadInt(r,nOfRuns);
  213.         FOR k := 0 TO nOfRuns-1 DO
  214.             Files.ReadInt(r,run[k].beg);
  215.             Files.ReadInt(r,run[k].end)
  216.         END
  217.     END ReadFontHeader;
  218.     PROCEDURE ReadRaster(VAR r:Files.Rider; VAR raster:Amiga.Font; VAR nOfRuns:INTEGER; VAR run:RunRecArray);
  219.         a:LONGINT;
  220.         j, bytesPerRow:LONGINT;
  221.         i,k,m:INTEGER;
  222.         nOfBytes:LONGINT;
  223.     BEGIN
  224.         nOfBytes:=0;
  225.         FOR k:=0 TO nOfRuns-1 DO
  226.             FOR m:=run[k].beg TO run[k].end-1 DO
  227.                 ReadShort(r,raster.info[m].dx);
  228.                 ReadShort(r,raster.info[m].x);
  229.                 ReadShort(r,raster.info[m].y);
  230.                 ReadShort(r,raster.info[m].w);
  231.                 ReadShort(r,raster.info[m].h);
  232.                 raster.info[m].modulo:=2*((raster.info[m].w+15) DIV 16);
  233.                 nOfBytes:=nOfBytes+raster.info[m].modulo*raster.info[m].h
  234.             END
  235.         END;
  236.         IF Amiga.ChipMemPool#0 THEN
  237.             raster.data:=E.AllocPooled(Amiga.ChipMemPool, nOfBytes)
  238.         ELSE
  239.             raster.data:=E.AllocMem(nOfBytes,{E.memChip})
  240.         END;
  241.         raster.size:=nOfBytes;
  242.         a:=raster.data;
  243.         FOR k:=0 TO nOfRuns-1 DO
  244.             FOR m:=run[k].beg TO run[k].end-1 DO
  245.                 bytesPerRow:=(raster.info[m].w+7) DIV 8;
  246.                 raster.info[m].data:=a;
  247.                 raster.info[m].offset:=0;
  248.                 INC(a,LONG(raster.info[m].modulo)*(raster.info[m].h-1));
  249.                 FOR i:=1 TO raster.info[m].h DO
  250.                     FOR j:=1 TO bytesPerRow DO
  251.                         Files.Read(r,ch);
  252.                         SYSTEM.PUT(a,Amiga.SwapBits[ORD(ch)]);
  253.                         INC(a)
  254.                     END;
  255.                     DEC(a,bytesPerRow+raster.info[m].modulo)
  256.                 END;
  257.                 a:=raster.info[m].data+raster.info[m].modulo*raster.info[m].h
  258.             END
  259.         END
  260.     END ReadRaster;
  261. BEGIN
  262.     file:=Files.Old(name);
  263.     IF file#NIL THEN
  264.         Files.Set(rider,file,0); Files.Read(rider,ch);
  265.         IF ch=FontFileId THEN
  266.             Files.Read(rider,ch);    (*skip abstraction*)
  267.             Files.Read(rider,ch);    (*skip family*)
  268.             Files.Read(rider,ch);    (*skip variant*)
  269.             NEW(font);
  270.             ReadFontHeader(rider,font,nOfRuns,run);
  271.             NEW(raster);
  272.             ClearRaster(raster);
  273.             ReadRaster(rider,raster,nOfRuns,run);
  274.             raster.amigaFont:=0;
  275.             font.raster:=SYSTEM.VAL(Display.Font,raster);
  276.             COPY(name,font.name);
  277.             font.next:=First;
  278.             First:=font
  279.         ELSE
  280.             font:=NIL
  281.         END
  282.     ELSE
  283.         font:=NIL
  284.     END;
  285.     RETURN font
  286. END OberonFont;
  287. PROCEDURE This*(name: ARRAY OF CHAR):Font;(*
  288. Load the named font, unless it is already loaded.
  289. First try to load it as Obeorn font.
  290. If this has no succsess, try it as Amiga font.
  291. After all does not work, use Default font.
  292.     font:Font;
  293. BEGIN
  294.     font:=SearchFont(name);
  295.     IF font=NIL THEN
  296.         font:=OberonFont(name);
  297.         IF font=NIL THEN
  298.             font:=AmigaFont(name);
  299.             IF font=NIL THEN font:=Default END
  300.         END
  301.     END;
  302.     RETURN font
  303. END This;
  304. BEGIN
  305.     First:=NIL;
  306.     nofFonts:=0;
  307.     Default:=This("Syntax10.Scn.Fnt");
  308.     Amiga.Assert(Default#NIL,"Default font not found");
  309.     Amiga.TermProcedure(Cleanup)
  310. END Fonts.
  311.